VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "Class2048"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Private Const m_nAnimationMaxTime As Long = 5

Private Declare Function FillRect Lib "user32.dll" (ByVal hdc As Long, ByRef lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32.dll" (ByVal crColor As Long) As Long
Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private m_nWidth As Long
Private m_nHeight As Long
Private m_nGameTarget As Long
Private m_nScore As Currency
Private m_bWin As Boolean, m_bGameOver As Boolean

Private m_bData(255) As Long

Private Type typeAnimation
 nAnimationType As Integer '0=normal, 1=fade in, 2=fade out
 nStartPosition As Byte
 nEndPosition As Byte
 nBlockType As Long
End Type

Private m_tAnimation(511) As typeAnimation
Private m_nAnimationCount As Long
Private m_nAnimationTime As Long

Private m_objLogic As I2048Logic

Private m_objRandom As clsMT19937

Friend Property Get IsWin() As Boolean
IsWin = m_bWin
End Property

Friend Property Let IsWin(ByVal b As Boolean)
m_bWin = b
End Property

Friend Property Get IsGameOver() As Boolean
IsGameOver = m_bGameOver
End Property

Friend Property Let IsGameOver(ByVal b As Boolean)
m_bGameOver = b
End Property

Friend Property Get GameTarget() As Long
GameTarget = m_nGameTarget
End Property

Friend Property Let GameTarget(ByVal n As Long)
m_nGameTarget = n
End Property

Private Sub AddAnimation(ByVal nAnimationType As Long, ByVal nStartPosition As Long, ByVal nEndPosition As Long, ByVal nBlockType As Long)
If m_nAnimationCount < 512 Then
 m_tAnimation(m_nAnimationCount).nAnimationType = nAnimationType
 m_tAnimation(m_nAnimationCount).nStartPosition = nStartPosition
 m_tAnimation(m_nAnimationCount).nEndPosition = nEndPosition
 m_tAnimation(m_nAnimationCount).nBlockType = nBlockType
 m_nAnimationCount = m_nAnimationCount + 1
 m_nAnimationTime = 0
End If
End Sub

Friend Property Get IsAnimating() As Boolean
IsAnimating = m_nAnimationCount > 0
End Property

Friend Sub OnTimer()
m_nAnimationTime = m_nAnimationTime + 1
If m_nAnimationTime >= m_nAnimationMaxTime Then
 m_nAnimationCount = 0
 m_nAnimationTime = 0
End If
End Sub

Friend Property Get LogicObject() As I2048Logic
Set LogicObject = m_objLogic
End Property

Friend Property Set LogicObject(ByVal obj As I2048Logic)
Set m_objLogic = obj
End Property

Friend Property Get RandomObject() As clsMT19937
Set RandomObject = m_objRandom
End Property

Friend Property Set RandomObject(ByVal obj As clsMT19937)
Set m_objRandom = obj
End Property

Friend Sub GetSize(ByRef nWidth As Long, ByRef nHeight As Long)
nWidth = m_nWidth
nHeight = m_nHeight
End Sub

Friend Sub SetSize(ByVal nWidth As Long, ByVal nHeight As Long)
If nWidth < 2 Then nWidth = 2 Else If nWidth > 16 Then nWidth = 16
If nHeight < 2 Then nHeight = 2 Else If nHeight > 16 Then nHeight = 16
m_nWidth = nWidth
m_nHeight = nHeight
End Sub

Friend Sub NewGame()
Erase m_bData
m_nScore = 0
m_nAnimationCount = 0
m_nAnimationTime = 0
m_bWin = False
m_bGameOver = False
'///
AddNewBlock
AddNewBlock
End Sub

Friend Function AddNewBlock() As Boolean
Dim p(255) As Long, m As Long
Dim i As Long, j As Long, k As Long
'///get available position
For j = 0 To m_nHeight - 1
 For i = 0 To m_nWidth - 1
  k = j * 16 + i
  If m_bData(k) = 0 Then
   p(m) = k
   m = m + 1
  End If
 Next i
Next j
'///
If m > 0 Then
 k = Int(m_objRandom.mt_random_real * m)
 k = p(k)
 i = m_objLogic.GetNewBlock(m_objRandom)
 m_bData(k) = i
 '///animation
 AddAnimation 1, k, k, i
 '///
 AddNewBlock = True
End If
'///check if game over
If m <= 1 And Not m_bWin Then
 For j = 0 To m_nHeight - 1
  For i = 0 To m_nWidth - 1
   k = j * 16 + i
   If m_bData(k) = 0 Then Exit Function
   If i < m_nWidth - 1 Then
    If m_objLogic.CanCombine(m_bData(k), m_bData(k + 1), 0, 0) Then Exit Function
   End If
   If j < m_nHeight - 1 Then
    If m_objLogic.CanCombine(m_bData(k), m_bData(k + 16), 0, 0) Then Exit Function
   End If
  Next i
 Next j
 m_bGameOver = True
End If
End Function

Private Sub DrawBlock(ByVal hdc As Long, ByRef fnt() As CLogFont, ByVal fntMax As Long, ByRef r As RECT, ByVal nType As Long)
Dim hbr As Long
Dim k As Long
Dim ww As Long, hh As Long
Dim clr As Long, s As String
'///
If nType Then
 m_objLogic.GetAppearance nType, clr, s
 '///draw background
 hbr = CreateSolidBrush(clr)
 FillRect hdc, r, hbr
 DeleteObject hbr
 '///get font size and draw
 For k = 0 To fntMax - 1
  ww = r.Right - r.Left
  hh = r.Bottom - r.Top
  fnt(k).VBDrawText hdc, s, 0, 0, ww, hh, DT_CALCRECT
  If ww <= r.Right - r.Left And hh <= ((r.Bottom - r.Top) * 5) \ 4 Then Exit For
 Next k
 fnt(k).VBDrawText hdc, s, r.Left, r.Top, r.Right - r.Left, r.Bottom - r.Top, DT_CENTER Or DT_VCENTER Or DT_SINGLELINE, clr Xor &H808080, , True
Else
 '///empty
 hbr = CreateSolidBrush(&HB4C0CD)
 FillRect hdc, r, hbr
 DeleteObject hbr
End If
End Sub

Friend Sub Draw(ByVal hdc As Long, ByVal bmCache As cAlphaDibSection, ByRef fnt() As CLogFont, ByVal x As Long, ByVal y As Long, ByVal w As Long, ByVal h As Long)
Dim hbr As Long
Dim i As Long, j As Long, k As Long
Dim r As RECT, r2 As RECT
Dim fntMax As Long
Dim t As typeAnimation
Dim s As String
'///
fntMax = UBound(fnt)
'///score
s = Format(m_nScore, "0.0000")
s = LTrim(Replace(Replace(s, ".", ""), "0", " "))
s = Replace(s, " ", "0")
If s = "" Then s = "0"
fnt(fntMax).VBDrawText hdc, "Score: " + s, x, y, w, 20, DT_LEFT Or DT_VCENTER Or DT_SINGLELINE, vbBlack, , True
'///
y = y + 20
w = (w + 4) \ m_nWidth
h = (h - 20) \ m_nHeight
If w > h Then w = h
'///blocks
For j = 0 To m_nHeight - 1
 r.Top = y + j * w
 r.Bottom = r.Top + w - 4
 For i = 0 To m_nWidth - 1
  r.Left = x + i * w
  r.Right = r.Left + w - 4
  If m_nAnimationCount > 0 Then k = 0 Else k = m_bData(j * 16 + i)
  DrawBlock hdc, fnt, fntMax, r, k
 Next i
Next j
'///animation
If m_nAnimationCount > 0 Then
 r2.Right = w - 4
 r2.Bottom = w - 4
 If bmCache.Width < r2.Right Then bmCache.Create r2.Right, r2.Right
 For i = 0 To m_nAnimationCount - 1
  t = m_tAnimation(i)
  '///calc position
  r.Left = t.nStartPosition
  r.Top = r.Left \ &H10&
  r.Left = r.Left And &HF&
  r.Right = t.nEndPosition
  r.Bottom = r.Right \ &H10&
  r.Right = r.Right And &HF&
  r.Left = x + w * (r.Left + (r.Right - r.Left) * m_nAnimationTime / m_nAnimationMaxTime)
  r.Top = y + w * (r.Top + (r.Bottom - r.Top) * m_nAnimationTime / m_nAnimationMaxTime)
  r.Right = r.Left + w - 4
  r.Bottom = r.Top + w - 4
  '///
  If t.nAnimationType = 0 Then
   DrawBlock hdc, fnt, fntMax, r, t.nBlockType
  Else
   DrawBlock bmCache.hdc, fnt, fntMax, r2, t.nBlockType
   k = (255& * m_nAnimationTime) \ m_nAnimationMaxTime
   If t.nAnimationType = 2 Then k = 255 - k
   bmCache.AlphaPaintPicture hdc, r.Left, r.Top, r2.Right, r2.Right, 0, 0, k, False
  End If
 Next i
End If
End Sub

'0-3=up,left,down,right
Friend Function Move(ByVal nDirection As Long) As Boolean
Dim i As Long, ret As Boolean
'///clear animation
m_nAnimationCount = 0
m_nAnimationTime = 0
'///
Select Case nDirection
Case 0 'up
 For i = 0 To m_nWidth - 1
  ret = ret Or MoveOneRow(i, 16, m_nHeight)
 Next i
Case 1 'left
 For i = 0 To m_nHeight - 1
  ret = ret Or MoveOneRow(i * 16, 1, m_nWidth)
 Next i
Case 2 'down
 For i = 0 To m_nWidth - 1
  ret = ret Or MoveOneRow((m_nHeight - 1) * 16 + i, -16, m_nHeight)
 Next i
Case 3 'right
 For i = 0 To m_nHeight - 1
  ret = ret Or MoveOneRow(i * 16 + m_nWidth - 1, -1, m_nWidth)
 Next i
End Select
'///over
If Not ret Then m_nAnimationCount = 0
Move = ret
End Function

'internal function
Private Function MoveOneRow(ByVal nStart As Long, ByVal nStep As Long, ByVal nCount As Long) As Boolean
Dim i As Long, j As Long
Dim ii As Long, tmp As Long
Dim nType As Long, nType2 As Long, nNewType As Long, sc As Currency
'1=we found empty blocks
'2=there are non-empty blocks after empty blocks, or some blocks combined
Dim ret As Long
Dim nNewBlocks(15) As Long
'///eliminate block and put blocks to a new array
ii = nStart
For i = 0 To nCount - 1
 tmp = m_bData(ii)
 If tmp Then 'find a non-empty block
  If ret = 1 Then ret = 2
  '///record it and add animation
  nNewBlocks(j) = tmp
  AddAnimation 0, ii, nStart + nStep * j, tmp
  j = j + 1
  '///
  nType = nType2
  nType2 = tmp
  If nType Then 'find two non-empty blocks, try to combine them
   nNewType = 0
   sc = 0
   If m_objLogic.CanCombine(nType, nType2, nNewType, sc) Then 'check it we can combine them
    '///change result, etc.
    ret = 2
    m_nScore = m_nScore + sc
    nType2 = 0
    If nNewType = m_nGameTarget Then m_bWin = True
    '///modifying existing blocks and animation
    nNewBlocks(j - 2) = nNewType
    nNewBlocks(j - 1) = 0
    m_tAnimation(m_nAnimationCount - 2).nAnimationType = 2
    j = j - 2
    tmp = nStart + nStep * j
    m_tAnimation(m_nAnimationCount - 1).nAnimationType = 2
    m_tAnimation(m_nAnimationCount - 1).nEndPosition = tmp
    If nNewType Then
     AddAnimation 1, ii, tmp, nNewType
     j = j + 1
    End If
   End If
  End If
 Else
  If ret = 0 Then ret = 1
 End If
 '///
 ii = ii + nStep
Next i
'///put them back
If ret >= 2 Then
 ii = nStart
 For i = 0 To nCount - 1
  m_bData(ii) = nNewBlocks(i)
  ii = ii + nStep
 Next i
 MoveOneRow = True
End If
End Function
